perm filename DPYIT.F4[MSS,LCS]2 blob
sn#095260 filedate 1974-03-30 generic text, type T, neo UTF8
00100 C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
00200 SUBROUTINE LINES(A,B,L)
00300 COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400 COMMON /FL/C,D,NQ,RZ,IXRX,XGP,RXGP
00500 DATA XGP/1200.0/,RX/1.1/
00600 COMMON/MN/M,N
00700 C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
00800 23 IF(IPLT)GO TO 2
00900 M=A*RSZ
01000 N=B*RSZ
01100 IF(L.EQ.3)GO TO 1
01200 CALL AVECT(M,N)
01300 RETURN
01400 1 CALL AIVECT(M,N)
01500 RETURN
01600 2 AX=.5
01700 IF(A)AX=-AX
01800 BX=.5
01900 IF(B)BX=-BX
02000 C AX AND BX ARE FOR ROUND-OFF
02100 DIS=RSZ*1.7
02200 RHT=RSZ*1.7
02300 IF(IXRX.EQ.0)GO TO 9
02400 M=-B*RHT-BX+RXGP
02500 N=RX*A*DIS+XGP+AX
02600 GO TO 8
02700 9 M=A*DIS+AX
02800 N=B*RHT+BX
02900 8 CALL PLOT(M,N,L)
03000 RETURN
03100 END
03200
03300 SUBROUTINE RDRAW(I,JJ,IJ,RJB,CENTR)
03400 C TO X,Y INTO ONE WORD
03500 DIMENSION IJ(1)
03600 COMMON/LL/L
03700 COMMON/ZN/SCLEF(200,2),DDD
03800 COMMON/MN/M,N
03900 DO 2 K=I,JJ
04000 CALL UNPACK(K,IA,IB,IJ)
04100 A=IA+RJB
04200 B=IB+CENTR
04300 IF(K.EQ.I.OR.L.GE.100000000)L=3
04400 CALL LINES(A,B,L)
04500 SCLEF(K,1)=M
04600 2 SCLEF(K,2)=N
04700 CALL DPYOUT(1)
04800 RETURN
04900 END
05000
05100 SUBROUTINE UNPACK(K,M,N,I)
05200 COMMON/LL/L
05300 C L IS FOR VIS. OR INVIS. LINES.
05400 DIMENSION I(1)
05600 N=I(K)
05700 L=0
05800 IF(N.LT.100000000)GO TO 2
05900 L=(N/100000000)*100000000
06000 N=N-L
06100 2 M=N/10000
06200 N=N-M*10000
06300 IF(M.GT.1000)M=1000-M
06400 IF(N.GT.1000)N=1000-N
06600 END
06700
06800 SUBROUTINE GRIDS
06900 COMMON /RC/MCLEF(200),IST(4000),MFILL(200)
07000 COMMON /RZ/RSZ,IPLT,RJB,CENTR
07100 CALL DPYSET(2,IST,200)
07200 CALL DPYBRT(3)
07300 RB=32
07400 RC=35
07500 RD=78
07600 RA=2
07700 CC IF(IPLT.LT.-1)GO TO 333
07800 C TO SKIP LINES
07900 DO 30 L=-34,78,4
08000 RZ=L
08100 RE=RZ+CENTR
08200 IF(L.NE.-2.AND.L.NE.18.AND.L.NE.38.AND.L.NE.58)GO TO 32
08300 RF=RE+1
08400 RG=RE+3
08500 CALL LINES(RJB-1.0,RG,3)
08600 CALL LINES(RJB+1.0,RF,2)
08700 CALL LINES(RJB+19.0,RG,3)
08800 CALL LINES(RJB+21.0,RF,2)
08900 32 XA=2
09000 XB=0
09100 IF(L.EQ.14.OR.L.EQ.42)XA=20
09200 IF(L.EQ.-2.OR.L.EQ.26.OR.L.EQ.54)XB=20
09300 CALL LINES(RJB-RA-XA,RE,3)
09400 CALL LINES(RJB+RB+XA,RE,2)
09500 CALL LINES(RJB+RB+XB,RE+2.0,3)
09600 30 CALL LINES(RJB-RA-XB,RE+2.0,2)
09700 DO 31 L=-2,32,4
09800 RZ=L
09900 RE=RZ+RJB
10000 CALL LINES(RE,CENTR-RC,3)
10100 CALL LINES(RE,CENTR+RD,2)
10200 CALL LINES(RE+2.0,CENTR+RD,3)
10300 31 CALL LINES(RE+2.0,CENTR-RC,2)
10400 CALL LINES(RJB-10.,CENTR-14.,3)
10500 CALL LINES(RJB,CENTR-14.,2)
10600 CALL LINES(RJB,CENTR-28.,3)
10700 CALL LINES(RJB-10.,CENTR-28.,2)
10800 CALL DPYOUT(2)
11000 END
11100
11200 SUBROUTINE SHIFT
11300 COMMON /RC/MCLEF(200),IST(4000),MFILL(200)
11400 COMMON/ED/K,NEXT,NN,NX,NY,J
11500 EQUIVALENCE(JJ,IST(1)),(KK,IST(2))
11600 COMMON/SH/H,V,SH,SV
11700 TYPE 1
11800 JJ=1
11900 KK=2
12000 ACCEPT 2,H,V,SH,SV
12100 IF(SH.EQ.0)SH=1
12200 IF(SV.EQ.0)SV=1
12300 CALL SHIFTX(MCLEF,JJ)
12600 1 FORMAT(' MOVE HORIZ, VERT., SIZE H, SIZE V'/)
12700 2 FORMAT(4F)
12800 END
12900
13000 SUBROUTINE SHIFTX(I,L)
13100 DIMENSION I(1)
13200 COMMON/SH/H,V,SH,SV
13300 JJ=I(L)
13400 2 DO 1 K=L+1,JJ
13500 CALL UNPACK(K,M,N,I)
13600 M=H+M*SH
13700 N=V+N*SV
13800 1 CALL REPACK(K,M,N,I)
13900 IF(JJ.EQ.I(1))RETURN
14000 L=1+JJ
14100 JJ=I(L)
14200 GO TO 2
14300 END
14400
14500 SUBROUTINE REPACK(K,M,N,I)
14600 COMMON/LL/L
14700 DIMENSION I(1)
14800 M=M*10000
14900 IF(M)M=10000000-M
15000 IF(N)N=1000-N
15100 M=M+L
15200 I(K)=M+N
15300 RETURN
15400 END